home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / structures / HanoiDiskRules < prev    next >
Encoding:
Text File  |  1988-05-28  |  2.2 KB  |  65 lines  |  [TEXT/CCL ]
  1. ; Ted Kaehler and Dave Patterson a taste of SmallTalk
  2. ; W. W. Norton ed., chapter 6, pp. 83 ff.
  3. ; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
  4. ; © Copyright 1988 Jean-Pascal J. LANGE.
  5.  
  6. (proclaim '(optimize (speed 3)
  7.             (space 0)
  8.             (safety 0)
  9.             (compilation-speed 0) ))
  10.  
  11. (defStruct (HanoiDiskRules (:include HanoiDisk))
  12.   ; previousPole : number of the pole this disk was on previously.
  13.   (previousPole nil) )
  14.  
  15. ; access
  16.  
  17. (deFun width (thisDisk)
  18. ; return the size of this disk
  19.   (HanoiDiskRules-width thisDisk) ) ; width
  20.  
  21. (deFun widthPoleRules (thisDisk size whichPole)
  22.   ; invoke widthPole for HanoiDisk structure
  23.   (widthPole thisDisk size whichPole)
  24.   (setf (HanoiDiskRules-previousPole thisDisk) 1) ) ; widthPoleRules
  25.  
  26. ; moving
  27.  
  28. (deFun bestMove (thisDisk)
  29. ; If thisDisk can move two places, which is the best? Return the top
  30. ; disk of the pole that this disk has not been on recently.
  31.   (declare (special *TheTowers*))
  32.   (let ((secondBest))
  33.     (cond
  34.      ((polesOtherThan
  35.        *TheTowers*
  36.        thisDisk
  37.        #'(lambda (targetDisk)
  38.            (cond ((< (width thisDisk)
  39.                      (width targetDisk) )
  40.                   (setq secondBest targetDisk)
  41.                   (if (not
  42.                        (= (pole targetDisk)
  43.                           (HanoiDiskRules-previousPole thisDisk) ) )
  44.                     targetDisk ) )) ) ) )
  45.      ; as a last resort, return a pole it was on recently
  46.      (t secondBest) ) ) ) ; bestMove
  47.  
  48. (deFun hasLegalMove (thisDisk)
  49. ; do either of the other two poles have a top disk large enough
  50. ; for this disk to rest on?
  51.   (declare (special *TheTowers*))
  52.   (polesOtherThan *TheTowers*
  53.                   thisDisk
  54.                   ; when a pole has no disk,
  55.                   ; targetDisk is a mock disk with infinite width
  56.                   #'(lambda (targetDisk)
  57.                       (< (width thisDisk)
  58.                          (width targetDisk) ) ) ) ) ; hasLegalMove
  59.  
  60. (deFun moveUponRules (thisDisk destination)
  61. ; this disk just moved. Record the new pole and tell the user.
  62.   (setf (HanoiDiskRules-previousPole thisDisk) (pole thisDisk))
  63.   ; run moveUpon defined for structure HanoiDisk
  64.   (moveUpon thisDisk destination) ) ; moveUponRules
  65.